Mental Health Continuum

Code

# recode response categories to numerics
df <- df %>% 
  mutate(across(starts_with("I1_"), ~ recode(.x,"'Aldrig'=0;
                    'En eller två gånger'=1;
                    '1 gång/vecka'=2;
                    '2-3 gånger/vecka'=3;
                    'Nästan dagligen'=4;
                    'Dagligen'=5",
                    as.factor = FALSE)
  ))

# koda om "Hur mår du rent allmänt?"
df <- df %>% 
  mutate(A1num = recode(A1,"'Mycket dåligt'=0;
                    'Dåligt'=1;
                    'Varken bra eller dåligt'=2;
                    'Bra'=3;
                    'Mycket bra'=4",
                    as.factor = FALSE)
  )

Code

# filter relevant variables, only respondents from 2019 with complete response data
df.omit.na <- df %>% 
  filter(inars %in% c(2019)) %>% 
  mutate(Årskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>% 
  select(starts_with("I1_"),Årskurs,Kön,Skolkommun) %>% 
  na.omit()

# create variables for analysis of Differential Item Functioning
dif.arskurs <- df.omit.na$Årskurs
dif.gender <- df.omit.na$Kön
dif.skolkommun <- df.omit.na$Skolkommun

df.omit.na$Årskurs <- NULL
df.omit.na$Kön <- NULL
df.omit.na$Skolkommun <- NULL

names(df.omit.na) <- itemlabels$itemnr

1 Demografiska data

Code

RIdemographics(dif.gender, "Kön")
RIdemographics(dif.arskurs, "Årskurs")
RIdemographics(dif.skolkommun, "Skolkommun")

Kön	n	Percent
Flickor	2798	49
Pojkar	2909	51

Årskurs	n	Percent
Åk 7	2029	35.6
Åk 9	2097	36.7
Gy 2	1581	27.7

Skolkommun	n	Percent
Älvkarleby	91	1.6
Enköping	572	10.0
Håbo	466	8.2
Heby	147	2.6
Knivsta	298	5.2
Östhammar	311	5.4
Tierp	312	5.5
Uppsala	3510	61.5

2 Deskriptiva data

Bakgrund om MHC kommer läggas till i kortfattat utförande.

Svarskategorierna som använts i enkäten och deras omkodning till siffror:

• Aldrig = 0
• En eller två gånger = 1
• 1 gång/vecka = 2
• 2-3 gånger/vecka = 3
• Nästan dagligen = 4
• Dagligen = 5

Code

RIallresp(df.omit.na)

Response category	Number of responses	Percent
0	10161	12.7
1	8721	10.9
2	8312	10.4
3	13460	16.8
4	19298	24.2
5	19946	25.0

Totalt antal svar per svarskategori för alla items

2.1 Descriptives - item level

itemnr	item
mhc1	lycka, glädje
mhc2	ett intresse för livet (att livet engagerar)
mhc3	dig nöjd/tillfredsställd
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc7	att människor i grunden är goda
mhc8	att det sätt som samhället fungerar på verkar begripligt
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Tile plot

Code

RItileplot(df.omit.na)

Stacked bars

Code

RIbarstack(df.omit.na)

Barplots

Code

RIbarplot(df.omit.na)

2.2 Tak/golv-effekt, rådata

Code

RIrawdist(df.omit.na)

3 Rasch-analys 1

The eRm package, which uses Conditional Maximum Likelihood (CML) estimation, will be used with the Partial Credit Model (PCM).

itemnr	item
mhc1	lycka, glädje
mhc2	ett intresse för livet (att livet engagerar)
mhc3	dig nöjd/tillfredsställd
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc7	att människor i grunden är goda
mhc8	att det sätt som samhället fungerar på verkar begripligt
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Item fit

Code

RIitemfitPCM2(df.omit.na, 250, 32, 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	0.856	0.851	-1.761	-1.348
mhc2	0.77	0.768	-2.776	-2.78
mhc3	0.796	0.788	-2.438	-2.468
mhc4	1.599	1.405	4.9	3.633
mhc5	1.311	1.179	1.69	1.758
mhc6	1.151	1.088	0.966	1.13
mhc7	1.074	1.048	0.83	0.727
mhc8	1.123	1.108	0.948	1.172
mhc9	0.728	0.741	-2.368	-2.871
mhc10	0.988	0.959	0.016	-0.577
mhc11	0.844	0.825	-1.507	-1.74
mhc12	0.967	0.947	-0.095	-0.937
mhc13	0.874	0.912	-1.146	-0.9
mhc14	0.713	0.733	-3.03	-3.02

PCA

Code

RIpcmPCA(df.omit.na)

PCA of Rasch model residuals

Eigenvalues
2.39
1.78
1.32
1.24
1.05

Residual correlations

Code

RIresidcorr(df.omit.na, cutoff = 0.2)

	mhc1	mhc2	mhc3	mhc4	mhc5	mhc6	mhc7	mhc8	mhc9	mhc10	mhc11	mhc12	mhc13	mhc14
mhc1
mhc2	0.4
mhc3	0.43	0.4
mhc4	-0.17	-0.13	-0.11
mhc5	-0.03	-0.07	-0.04	-0.03
mhc6	-0.19	-0.19	-0.2	-0.01	-0.11
mhc7	-0.17	-0.2	-0.22	-0.14	-0.1	0.24
mhc8	-0.21	-0.25	-0.24	-0.13	-0.1	0.29	0.3
mhc9	-0.03	-0.03	-0.01	-0.19	-0.16	-0.18	-0.16	-0.15
mhc10	-0.14	-0.11	-0.1	-0.13	-0.15	-0.15	-0.14	-0.09	0.05
mhc11	-0.01	-0.1	-0.06	-0.18	0.07	-0.23	-0.1	-0.18	0.02	0.05
mhc12	-0.17	-0.17	-0.18	-0.04	-0.17	-0.13	-0.15	-0.13	-0.07	0.02	0.04
mhc13	-0.12	-0.15	-0.13	-0.06	-0.11	-0.21	-0.2	-0.18	0.13	-0.04	-0.02	0.1
mhc14	-0.08	0.09	-0.03	-0.11	-0.19	-0.2	-0.18	-0.2	0.07	0.03	-0.06	0.06	0.07
Note:
Relative cut-off value (highlighted in red) is 0.13, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df.omit.na)

Analysis of response categories

Code

RIitemCats(df.omit.na)

Targeting

Code

RItargeting(df.omit.na)

Item hierarchy

Code

RIitemHierarchy(df.omit.na)

Item 4 har hög item fit.

PCA av residualerna ger ett största eigenvalue på över 2.0, vilket indikerar att det finns mer än en dimension i data.

Residualkorrelationerna visar på två kluster, ett som består av items 1-3 och ett med items 6-8.

Items 4, 6, 7 och 8 har alla att göra med upplevelser av samhället och gemenskap och hänger samman med varandra i ett kluster. Item 4 ligger något närmare övriga items än vad 6-8 gör.

Samtliga items har problem med oordnade svarskategorier. Det innebär att respondenterna inte skiljer på svarskategorierna på ett systematiskt och tydligt sätt, och att de inte bidrar med meningsfull information i sin nuvarande form. Det kan antingen bero på att det är för många svarskategorier eller att svarskategoriernas etiketter är för “nära” varandra.

Svarskategorierna som använts i enkäten är:

• Aldrig = 0
• En eller två gånger = 1
• 1 gång/vecka = 2
• 2-3 gånger/vecka = 3
• Nästan dagligen = 4
• Dagligen = 5

Vi slår samman kategori 0+1 och 2+3.

3.1 Sammanslagning av svarskategorier

Code

for (i in itemlabels$itemnr) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

Tile plot

Code

RItileplot(df.omit.na)

ICC plots

Code

RIitemCats(df.omit.na)

Nu är alla items svarskategorier ordnade, även om det är väldigt små avstånd mellan många tröskelvärden. Figuren nedan under “itemhierarki” visar 95% konfidensintervall runt varje items trösklar.

Vi kör om analysen för att se hur detta påverkat övriga parametrar.

4 Rasch-analys 2

itemnr	item
mhc1	lycka, glädje
mhc2	ett intresse för livet (att livet engagerar)
mhc3	dig nöjd/tillfredsställd
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc7	att människor i grunden är goda
mhc8	att det sätt som samhället fungerar på verkar begripligt
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Item fit

Code

RIitemfitPCM2(df.omit.na, 250, 32, 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	0.902	0.874	-0.867	-1.519
mhc2	0.794	0.787	-2.072	-2.625
mhc3	0.787	0.781	-2.641	-2.992
mhc4	1.475	1.327	3.038	2.926
mhc5	1.263	1.168	2.084	1.384
mhc6	1.077	1.012	0.53	0.108
mhc7	1.076	1.029	0.781	0.463
mhc8	1.083	1.046	0.435	0.664
mhc9	0.742	0.752	-2.899	-2.817
mhc10	1.065	0.997	0.328	-0.103
mhc11	0.872	0.858	-1.133	-1.653
mhc12	1.024	0.996	0.556	0.067
mhc13	0.97	0.955	-0.343	-0.499
mhc14	0.74	0.752	-2.46	-3.004

PCA

Code

RIpcmPCA(df.omit.na)

PCA of Rasch model residuals

Eigenvalues
2.19
1.80
1.32
1.25
1.08

Residual correlations

Code

RIresidcorr(df.omit.na, cutoff = 0.2)

	mhc1	mhc2	mhc3	mhc4	mhc5	mhc6	mhc7	mhc8	mhc9	mhc10	mhc11	mhc12	mhc13	mhc14
mhc1
mhc2	0.34
mhc3	0.38	0.35
mhc4	-0.16	-0.13	-0.1
mhc5	-0.05	-0.08	-0.05	-0.04
mhc6	-0.16	-0.15	-0.17	0	-0.1
mhc7	-0.15	-0.17	-0.2	-0.1	-0.1	0.25
mhc8	-0.19	-0.21	-0.2	-0.1	-0.11	0.28	0.29
mhc9	-0.06	-0.07	-0.04	-0.17	-0.16	-0.13	-0.12	-0.1
mhc10	-0.16	-0.13	-0.14	-0.13	-0.15	-0.12	-0.13	-0.08	0.03
mhc11	-0.04	-0.11	-0.09	-0.18	0.09	-0.21	-0.1	-0.16	-0.01	0.03
mhc12	-0.19	-0.19	-0.2	-0.02	-0.17	-0.11	-0.14	-0.12	-0.08	0.02	0
mhc13	-0.15	-0.18	-0.16	-0.04	-0.1	-0.19	-0.19	-0.16	0.1	-0.07	-0.05	0.09
mhc14	-0.12	0.05	-0.07	-0.09	-0.18	-0.16	-0.17	-0.17	0.04	0.01	-0.08	0.04	0.06
Note:
Relative cut-off value (highlighted in red) is 0.127, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df.omit.na)

Targeting

Code

# increase fig-height above as needed, if you have many items
RItargeting(df.omit.na)

Item hierarchy

Code

RIitemHierarchy(df.omit.na)

Vi ser samma klustring i residualkorrelationerna av items 1-3. Samtliga är breda, generella frågor om välbefinnande. Item 2 och 3 har också låg item fit, vilket indikerar att de bidrar med relativt lite information. Targeting visar att 2 och 3 ligger nära varandra och nära mitten av distributionen (något under). Vi kommer förmodligen bara kunna behålla ett item av dessa tre, och item 1 verkar lämpligast, följt av item 2.

Items 6, 7 och 8 har starka residualkorrelationer sinsemellan. Fråga 8 ter sig mindre innehållsmässigt relevant, och tas därför bort.

Det är intressant att se hur items 4 och 6-8 ligger klart högst i itemhierarkin.

Item 4 har fortfarande för hög item fit och verkar inte passa in, men vi behåller den ett tag till p.g.a. targeting, och för att se vad som händer när vi tar bort andra items.

Således tar vi bort (pga residualkorrelationer):

• items 3 och 8

Code

removed.items <- c("mhc3","mhc8")
df2 <- df.omit.na %>% 
  select(!any_of(removed.items))

5 Rasch-analys 3

itemnr	item
mhc1	lycka, glädje
mhc2	ett intresse för livet (att livet engagerar)
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc7	att människor i grunden är goda
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Item fit

Code

RIitemfitPCM2(df2, 250, 32, 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	0.921	0.901	-0.583	-1.371
mhc2	0.816	0.808	-2.185	-2.424
mhc4	1.402	1.285	2.197	2.542
mhc5	1.216	1.147	1.89	1.556
mhc6	1.091	1.038	1.147	0.466
mhc7	1.096	1.055	1.102	0.401
mhc9	0.725	0.738	-3.122	-3.274
mhc10	1.017	0.97	-0.02	-0.239
mhc11	0.826	0.825	-1.515	-2.009
mhc12	0.966	0.952	-0.417	-0.536
mhc13	0.909	0.911	-1.039	-0.855
mhc14	0.704	0.723	-3.024	-3.858

PCA

Code

RIpcmPCA(df2)

PCA of Rasch model residuals

Eigenvalues
1.67
1.63
1.32
1.24
1.11

Residual correlations

Code

RIresidcorr(df2, cutoff = 0.2)

	mhc1	mhc2	mhc4	mhc5	mhc6	mhc7	mhc9	mhc10	mhc11	mhc12	mhc13	mhc14
mhc1
mhc2	0.36
mhc4	-0.16	-0.13
mhc5	-0.04	-0.08	-0.05
mhc6	-0.14	-0.12	0	-0.09
mhc7	-0.12	-0.14	-0.1	-0.1	0.27
mhc9	-0.04	-0.06	-0.19	-0.18	-0.12	-0.11
mhc10	-0.15	-0.13	-0.15	-0.18	-0.11	-0.12	0.01
mhc11	-0.03	-0.12	-0.2	0.07	-0.2	-0.1	-0.04	0
mhc12	-0.19	-0.2	-0.05	-0.2	-0.11	-0.14	-0.11	-0.01	-0.03
mhc13	-0.15	-0.19	-0.07	-0.13	-0.19	-0.2	0.07	-0.1	-0.08	0.05
mhc14	-0.11	0.05	-0.12	-0.21	-0.16	-0.16	0.01	-0.02	-0.11	0	0.03
Note:
Relative cut-off value (highlighted in red) is 0.115, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df2)

Targeting

Code

# increase fig-height above as needed, if you have many items
RItargeting(df2)

Item hierarchy

Code

RIitemHierarchy(df2)

Stora residualkorrelationer kvarstår mellan 1 och 2 samt 6 och 7. Vi tar bort 2 och 7.

Item 4 ser något bättre ut nu, men fortfarande hög item fit. Den får vara kvar ett steg till.

Code

removed.items <- c("mhc2","mhc3","mhc8","mhc7")
df2 <- df.omit.na %>% 
  select(!any_of(removed.items))

6 Rasch-analys 4

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Item fit

Code

RIitemfitPCM2(df2, 250, 32, 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	0.979	0.956	-0.079	-0.791
mhc4	1.34	1.238	1.867	2.362
mhc5	1.177	1.13	1.479	1.201
mhc6	1.18	1.092	1.547	0.919
mhc9	0.707	0.722	-3.109	-3.28
mhc10	0.969	0.939	-0.553	-0.564
mhc11	0.797	0.802	-2.031	-2.547
mhc12	0.908	0.904	-0.94	-1.207
mhc13	0.838	0.854	-1.742	-1.94
mhc14	0.695	0.717	-2.977	-3.526

PCA

Code

RIpcmPCA(df2)

PCA of Rasch model residuals

Eigenvalues
1.50
1.42
1.20
1.17
1.04

Residual correlations

Code

RIresidcorr(df2, cutoff = 0.2)

	mhc1	mhc4	mhc5	mhc6	mhc9	mhc10	mhc11	mhc12	mhc13	mhc14
mhc1
mhc4	-0.15
mhc5	-0.02	-0.07
mhc6	-0.1	0.01	-0.08
mhc9	-0.02	-0.22	-0.2	-0.1
mhc10	-0.14	-0.19	-0.21	-0.1	-0.01
mhc11	-0.02	-0.23	0.04	-0.19	-0.06	-0.03
mhc12	-0.19	-0.09	-0.24	-0.11	-0.15	-0.05	-0.07
mhc13	-0.15	-0.11	-0.18	-0.19	0.03	-0.15	-0.13	0
mhc14	-0.08	-0.14	-0.22	-0.13	0	-0.04	-0.13	-0.03	-0.01
Note:
Relative cut-off value (highlighted in red) is 0.097, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df2)

Targeting

Code

# increase fig-height above as needed, if you have many items
RItargeting(df2)

Item hierarchy

Code

RIitemHierarchy(df2)

Denna uppsättning items fungerar relativt väl tillsammans. Några items har något låga värden på item fit ZSTD, vilket inte är idealiskt men acceptabelt. Item 4 har något hög item fit, men kompletterar väl innehållsmässigt och sett till targeting där både 4 och 6 sticker ut. Figuren med faktorladdningar på första residualkontrasten visar också att item 4 och 6 avviker något, där item 4 gör det mera än 6. Detta indikerar viss multidimensionalitet rörande frågorna som innehåller “samhället”.

Vi tittar kort på MHC utan dessa två items:

Code

df2 %>% 
  select(!mhc4) %>% 
  select(!mhc6) %>% 
  RIitemfitPCM2(.,250,32,8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	1.022	0.994	0.162	-0.528
mhc5	1.345	1.201	2.673	1.948
mhc9	0.742	0.745	-2.877	-3.123
mhc10	1.017	0.981	0.061	-0.079
mhc11	0.801	0.792	-2.139	-2.26
mhc12	1.001	0.982	0.205	-0.106
mhc13	0.886	0.885	-1.091	-1.355
mhc14	0.743	0.749	-2.928	-3.106

Code

df2 %>% 
  select(!mhc4) %>% 
  select(!mhc6) %>% 
  RItargeting()

Takeffekten blir tydlig.

Vi återgår till att ha med item 4 och 6 och undersöker invarians.

7 DIF-analys

7.1 Kön

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df2, dif.gender)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.786	-0.817	-0.802	0.022	0.031
mhc4	1.077	1.063	1.070	0.010	0.014
mhc5	-0.541	-0.319	-0.430	0.157	0.222
mhc6	1.657	1.385	1.521	0.193	0.272
mhc9	0.017	-0.255	-0.119	0.192	0.272
mhc10	-0.367	-0.123	-0.245	0.173	0.244
mhc11	-0.843	-0.461	-0.652	0.270	0.382
mhc12	0.011	0.133	0.072	0.087	0.122
mhc13	-0.186	-0.402	-0.294	0.153	0.216
mhc14	-0.038	-0.204	-0.121	0.117	0.165

Locations

Code

RIdifFigure(df2, dif.gender)

Thresholds

Code

RIdifFigThresh(df2, dif.gender)

Item 11, varma och tillitsfulla relationer med andra, är närmast gränsvärdet på 0.5 logits, ej problematiskt sammantaget. Det är framför allt den lägsta tröskeln som skiljer sig mellan pojkar och flickor.

7.2 Årskurs

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df2, dif.arskurs)

Item	2	4	5	Mean location	StDev	MaxDiff
mhc1	-0.878	-0.844	-0.657	-0.793	0.119	0.221
mhc4	1.168	1.005	1.009	1.061	0.093	0.163
mhc5	-0.367	-0.431	-0.499	-0.432	0.066	0.132
mhc6	1.326	1.572	1.630	1.509	0.161	0.304
mhc9	-0.105	-0.100	-0.161	-0.122	0.034	0.060
mhc10	-0.360	-0.240	-0.083	-0.228	0.139	0.276
mhc11	-0.616	-0.612	-0.732	-0.653	0.068	0.119
mhc12	0.149	0.067	-0.002	0.071	0.076	0.151
mhc13	-0.182	-0.287	-0.406	-0.292	0.112	0.223
mhc14	-0.135	-0.129	-0.101	-0.121	0.018	0.034

Locations

Code

RIdifFigure(df2, dif.arskurs)

Thresholds

Code

RIdifFigThresh(df2, dif.arskurs)

Node 3 = åk 7, Node 4 = åk 9, Node 5 = Gy 2.

7.3 Kön och årskurs

Vi undersöker även interaktionen mellan kön och årskurs.

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Tabell

Code

dfin <- df2

df.tree <- data.frame(matrix(ncol = 0, nrow = nrow(dfin)))
df.tree$difdata <- as.matrix(dfin)
df.tree$dif.gender <- dif.gender
df.tree$dif.arskurs <- dif.arskurs

pctree.out <- pctree(difdata ~ dif.gender + dif.arskurs, data = df.tree)
plot(pctree.out)

Code

cutoff <- 0.5
diffig <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  mutate(
    `Mean location` = rowMeans(.),
    StDev = rowSds(as.matrix(.))
  ) %>%
  rowwise() %>%
  mutate(MaxDiff = (max(c_across(c(1:(ncol(.) - 2))))) -
    min(c_across(c(1:(ncol(.) - 2))))) %>%
  ungroup() %>%
  mutate(across(where(is.numeric), round, 3)) %>%
  rownames_to_column(var = "Item") %>%
  mutate(Item = names(dfin)) %>%
  relocate(MaxDiff, .after = last_col()) 

  formattable(diffig,
    list(MaxDiff = formatter("span",
      style = ~ style(color = ifelse(MaxDiff < -cutoff,
        "red", ifelse(MaxDiff > cutoff, "red", "black")
      ))
    ),
    formattable::area(col = 2:6) ~ color_tile(RISEprimYellowLight, RISEprimGreen)
    ),
    table.attr = "class=\"table table-striped\" style=\"font-size: 15px; font-family: Lato\""
  )

Item	4	5	6	8	10	11	Mean location	StDev	MaxDiff
mhc1	-0.826	-0.806	-0.711	-0.951	-0.889	-0.605	-0.798	0.124	0.346
mhc4	1.191	0.989	1.047	1.162	1.032	0.990	1.068	0.088	0.203
mhc5	-0.591	-0.465	-0.595	-0.151	-0.405	-0.420	-0.438	0.163	0.444
mhc6	1.550	1.708	1.761	1.184	1.495	1.551	1.542	0.203	0.577
mhc9	0.007	0.015	0.033	-0.223	-0.233	-0.323	-0.121	0.156	0.356
mhc10	-0.457	-0.399	-0.204	-0.275	-0.090	0.012	-0.235	0.179	0.469
mhc11	-0.823	-0.801	-0.940	-0.418	-0.433	-0.556	-0.662	0.222	0.523
mhc12	0.110	0.005	-0.114	0.185	0.120	0.089	0.066	0.106	0.299
mhc13	-0.104	-0.187	-0.298	-0.294	-0.405	-0.539	-0.305	0.154	0.435
mhc14	-0.058	-0.059	0.022	-0.219	-0.193	-0.199	-0.118	0.099	0.241

Figur

Code

pctree.par <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame()
pctree.par$Item <- names(dfin)
pctree.par$item <- NULL
rownames(pctree.par) <- NULL
pctree.par <- melt(pctree.par, id.vars = "Item")
names(pctree.par) <- c("Item", "Group", "Logits")
pctree.par$Item <- factor(pctree.par$Item, levels = names(dfin))
ggplot(pctree.par, aes(
  x = Item, y = Logits, color = Group,
  group = Group
)) +
  geom_line(linewidth = 1.5, alpha = 0.8) +
  geom_point(size = 2.5)

Items 6 och 11 uppvisar skillnader strax över gränsvärdet. Båda mellan flickor i gy 2 och pojkar i åk 7. För item 6 uppvisar flickorna högre item location än pojkarna, och omvänt för item 11. Det innebär att de förmodligen tar ut DIF-effekten när mätvärden estimeras.

Items 5 och 10 ligger också strax under gränsvärdet, och för item 5 gäller det samma grupper.

7.4 Skolkommun

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df2, dif.skolkommun)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.835	-0.791	-0.813	0.031	0.044
mhc4	1.150	1.044	1.097	0.075	0.106
mhc5	-0.333	-0.450	-0.391	0.083	0.117
mhc6	1.335	1.531	1.433	0.138	0.196
mhc9	-0.077	-0.132	-0.104	0.039	0.054
mhc10	-0.312	-0.215	-0.264	0.069	0.097
mhc11	-0.620	-0.651	-0.636	0.022	0.031
mhc12	0.071	0.078	0.075	0.005	0.007
mhc13	-0.273	-0.285	-0.279	0.009	0.012
mhc14	-0.105	-0.130	-0.117	0.017	0.025

Locations

Code

RIdifFigure(df2, dif.skolkommun)

Thresholds

Code

RIdifFigThresh(df2, dif.skolkommun)

Inga problem.

7.5 Årtal

Code

removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.difyears <- df %>% 
  mutate(Årtal = factor(inars)) %>% 
  select(starts_with("I1_"),Årtal) %>% 
  na.omit()

dif.years <- df.difyears$Årtal
df.difyears$Årtal <- NULL

names(df.difyears) <- itemlabels$itemnr

for (i in itemlabels$itemnr) {
  df.difyears[[i]] <- recode(df.difyears[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.difyears <- df.difyears %>% 
  select(!any_of(removed.items))

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df.difyears, dif.years)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.798	-0.967	-0.882	0.119	0.168
mhc4	1.050	1.165	1.108	0.081	0.115
mhc5	-0.418	-0.409	-0.413	0.006	0.009
mhc6	1.478	1.560	1.519	0.058	0.082
mhc9	-0.121	-0.174	-0.148	0.037	0.053
mhc10	-0.230	-0.202	-0.216	0.020	0.028
mhc11	-0.635	-0.644	-0.639	0.006	0.009
mhc12	0.076	0.056	0.066	0.014	0.020
mhc13	-0.281	-0.273	-0.277	0.006	0.008
mhc14	-0.121	-0.113	-0.117	0.006	0.008

Locations

Code

RIdifFigure(df.difyears, dif.years)

Thresholds

Code

RIdifFigThresh(df.difyears, dif.years)

Inga problem.

7.6 DIF sammanfattning

Överlag fungerar items stabilt mellan kön, årskurs, kommun och över tid. Interaktionen mellan årskurs och kön visar på skillnader gällande vissa items, men inte i problematiska nivåer sammantaget med antalet items.

8 Reliabilitet

Code

RItif(df.difyears)

9 Item-parametrar

Code

RIitemparams(df.difyears)

	Threshold 1	Threshold 2	Threshold 3	Item location
mhc1	-2.18	-0.50	0.96	-0.57
mhc4	0.70	1.58	1.98	1.42
mhc5	-0.66	-0.12	0.48	-0.1
mhc6	0.92	1.98	2.58	1.83
mhc9	-0.89	0.34	1.04	0.16
mhc10	-1.17	0.36	1.10	0.1
mhc11	-1.51	-0.08	0.61	-0.33
mhc12	-0.90	0.89	1.14	0.38
mhc13	-1.02	0.39	0.74	0.03
mhc14	-0.64	0.53	0.70	0.19

Code

# write final item names and descriptions to a file
itemlabels %>% 
  filter(itemnr %in% names(df.difyears)) %>% 
  write_csv("mhcItemnr.csv")

10 Transformeringstabell

Code

RIscoreSE(df.difyears)

Ordinal sum score	Logit score	Logit std.error
0	-4.000	1.435
1	-2.904	0.890
2	-2.306	0.706
3	-1.890	0.609
4	-1.565	0.547
5	-1.296	0.503
6	-1.065	0.470
7	-0.860	0.445
8	-0.675	0.426
9	-0.506	0.410
10	-0.347	0.398
11	-0.198	0.389
12	-0.054	0.382
14	0.221	0.374
15	0.355	0.372
16	0.489	0.372
17	0.624	0.374
18	0.761	0.378
19	0.901	0.383
20	1.047	0.391
21	1.198	0.400
22	1.359	0.413
23	1.530	0.429
24	1.716	0.449
25	1.922	0.476
26	2.156	0.513
27	2.435	0.568
28	2.788	0.656
29	3.301	0.828
30	4.000	1.165

11 Visualiseringar

Code

# prepare dataframe with all data and variables of interest
removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.viz <- df %>% 
  mutate(Årtal = factor(inars),
         Årskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>% 
  select(starts_with("I1_"),Årtal,Årskurs,Kön,Skolkommun,A1)

# koda om "Hur mår du rent allmänt?"
df.viz <- df.viz %>% 
  mutate(A1num = recode(A1,"'Mycket dåligt'=0;
                    'Dåligt'=1;
                    'Varken bra eller dåligt'=2;
                    'Bra'=3;
                    'Mycket bra'=4",
                    as.factor = FALSE)
  ) %>% 
  rename_at(vars(starts_with("I1_")), ~ itemlabels$itemnr) %>% 
  select(!any_of(removed.items))

Code

# estimate MHC person locations based on Rasch analysis

# define final set of items
scale.items <- df.viz %>% 
  select(starts_with("mhc")) %>% 
  names()

# create id-variable to re-join data later
df.viz$individID <- seq.int(nrow(df.viz))

# filter out those with fewer than 6 item responses
min.responses <- 6
# create new dataframe based on the filtering
df.omit.na <- df.viz %>% 
  select(starts_with("mhc"),individID) %>%
  filter(length(scale.items)-rowSums(is.na(.[scale.items])) >= min.responses)

# save the vector of ID's for merging dataframes later
idnr <- df.omit.na$individID
# then remove it
df.omit.na$individID <- NULL

# read item threshold locations previously estimated
items <- as.matrix(read_csv("itemParameters.csv"))

# recode raw responses according to analysis
for (i in names(df.omit.na)) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

Code

### This chunk is not run when rendering the HTML report, since theta estimation takes a lot of time.

# load library and estimate person locations/scores
library(catR)
thetaEstScores <- c()
for (i in 1:nrow(df.omit.na)){
  p1 <- as.numeric(as.vector(df.omit.na[i,]))
  ptheta <- thetaEst(items, p1, model = "PCM", method = "WL")
  thetaEstScores <- c(thetaEstScores,ptheta)
}

# insert interval scores to new df
thetas <- as.data.frame(thetaEstScores) %>%  
  mutate(across(where(is.numeric),round,3)) # round to 3 digits

# insert id variable to new df
thetas$individ <- idnr 
names(thetas) <- c("mhcScore","individID") 

# merge to a new dataframe which includes raw responses
df.viz <- merge(df.viz, thetas,
                   by = "individID", all = T)

# write visualization df to file to speed up things later
#write_parquet(df.viz, glue("/Volumes/magnuspjo/RegionUppsala/data/{Sys.Date()}_mhcScored.parquet"))

Code

# read estimated person thetas
df.viz <- read_parquet("/Volumes/magnuspjo/RegionUppsala/data/2023-03-31_mhcScored.parquet")
scale.items <- df.viz %>% 
  select(starts_with("mhc")) %>% 
  select(!mhcScore) %>% 
  names()

11.1 MHC över tid

Kön

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,3)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Skolkommun

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på skolkommun",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Kön och skolkommun

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~Kön)

Förstorat

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  scale_y_continuous(limits = c(-0.5,1)) +
  scale_color_manual(values = RISEpalette2) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~Kön)

Skolkommun och kön 2

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_grid(Kön~Skolkommun)

Årskurs

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Årskurs, color = Årskurs, fill = Årskurs)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Årskurs och kön

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön och årskurs",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~ Årskurs)

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Årskurs, color = Årskurs, fill = Årskurs)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön och årskurs",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~ Kön)

Total fördelning

Code

df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(side = "right", show.legend = F,
            scale = 0.6, # defines the height that a slab can reach
            position = position_dodge(width=.6), # distance between elements for dodging
            aes(fill_ramp = after_stat(level), fill=Årtal),
            .width = c(.50,.80,1)) +  # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
               position = position_dodge2nudge(x=.05,width = .8)) +
  scale_fill_ramp_discrete(from='black', aesthetics = "fill_ramp") +
  #scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(axis.text.x = element_text(size=ax.size, family = "sans"),
        #axis.text.y = element_blank(),
        title = element_text(size=title.size),
  )+
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer")

12 “Hur mår du rent allmänt?”

Frågeställningen verkar fram till och med 2015 varit “Hur mår du?”, och ändrades 2017 till “Hur mår du rent allmänt?”. Svarsalternativen verkar ha varit samma från 2013 till och med 2021 (det jag har uppgifter om).

Code

# function for Wilson's proportional confidence interval, from:
# https://github.com/rpruim/fastR2/blob/main/R/wilson.ci.R
wilson.ci <- function (x, n = 100, conf.level = 0.95) {
    alpha = 1 - conf.level
    p = (x + 2)/(n + 4)
    zstar <- -qnorm(alpha/2)
    interval <- p + c(-1, 1) * zstar * sqrt(p * (1 - p)/(n+4))
    attr(interval, "conf.level") <- conf.level
    return(interval)
}

Code

df.A1 <- df.viz %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1) %>% 
  group_by(Årtal) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

# with gender grouping
df.A1g <- df.viz %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1, Kön) %>% 
  group_by(Årtal,Kön) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

Code

# grouped responses

df.A1grouped <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1) %>% 
  group_by(Årtal) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

df.A1groupedSK <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  filter(!is.na(Skolkommun)) %>% 
  select(Årtal, A1, Skolkommun) %>% 
  group_by(Årtal,Skolkommun) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

12.0.1 Grupperade svar

Detta är en “kopia” av figuren som Region Uppsala har med i sina rapporter. Där har man slagit samman de två högsta svarskategorierna till en och samma (Bra och Mycket bra).

Code

# get max/min for every year, based on municipalities grouping
yminSK <- df.A1groupedSK %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  select(Procent) %>% 
  group_by(År) %>% 
  summarise(ymin = min(Procent)) %>% 
  pull(ymin)

ymaxSK <- df.A1groupedSK %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  select(Procent) %>% 
  group_by(År) %>% 
  summarise(ymax = max(Procent)) %>% 
  pull(ymax)

årtal <- df.A1grouped %>% 
  distinct(År) %>% 
  mutate(År = as.numeric(as.character(År))) %>% 
  pull()

df.A1grouped %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  mutate(År = as.numeric(as.character(År))) %>% 
  ggplot(aes(x = År, y = Procent, color = RISEprimGreen, fill = RISEprimGreen)) +
    geom_ribbon(aes(ymin = yminSK, ymax = ymaxSK),
              alpha = 0.5, linetype = 0, fill = "grey70") +
  geom_point(size = 12) +
  geom_line(aes(group = 1), linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,100), breaks = c(0,20,40,60,80,100)) +
  scale_x_continuous(breaks = årtal, 
                     minor_breaks = NULL) +
  scale_color_manual(values = RISEprimGreen, guide = "none") +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Samtliga respondenter som svarat 'Bra' eller 'Mycket bra'",
       caption = "Skuggat fält indikerar högsta och lägsta medelvärde bland deltagande skolkommuner") +
  ylab("Andel respondenter i procent") +
  theme_minimal() +
  theme_rise() +
  theme(legend.position = "none")

Code

# grouped responses

df.A1groupedG <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, Kön, A1) %>% 
  group_by(Årtal, Kön) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

Code

df.A1groupedG %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 12) +
  geom_line(linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,100), breaks = c(0,20,40,60,80,100)) +
  scale_color_manual(values = RISEpalette1[c(1,5)])  +
    labs(title = "Hur mår du rent allmänt?",
       subtitle = "Flickor och pojkar i åk 7, 9 och gy 2 som svarat 'Bra' eller 'Mycket bra'") +
  ylab("Andel respondenter i procent") +
  theme_minimal() +
  theme_rise() +
  theme(legend.background = element_rect(color = "lightgrey"))

12.0.2 Uppdelade svarskategorier

Code

df.A1 %>% 
  filter(Svarsalternativ %in% c("Bra","Mycket bra")) %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(size = 12) +
  geom_line(aes(group = Svarsalternativ), linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,80), breaks = c(0,20,40,60,80)) +
  scale_color_manual(values = RISEpalette1) +
  labs(title = "Samtliga respondenter") +
  theme_minimal() +
  theme_rise() +
  theme(legend.background = element_rect(color = "lightgrey"))

Code

library(ggiraph)
df.A1g %>% 
  filter(Svarsalternativ %in% c("Bra","Mycket bra")) %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(aes(tooltip = round(Procent,1)),
                         size = 4) +
  geom_line(aes(group = Svarsalternativ), linewidth = 1.5) +
  #geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,60), breaks = c(0,20,40,60)) +
  scale_x_discrete(guide = guide_axis(n.dodge = 2)) +
  scale_color_manual(values = RISEpalette1) +
  facet_wrap(~Kön) +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code

#girafe(ggobj = MHCgroupedGfig)

12.0.3 Senaste tre åren, alla svarskategorier

Code

df.A1 %>%
  filter(År %in% c("2017","2019","2021")) %>% 
  filter(!is.na(Svarsalternativ)) %>% 
  mutate(Procent = round(Procent, 1)) %>% # avrunda till en decimal
  mutate(procentText = sprintf("%1.1f%%", Procent)) %>% # skriv data med %-tecken
  ggplot(aes(x = Svarsalternativ, y = Procent, group = År, fill = År)) + # gör en figur grupperad och kolorerad utifrån år
  geom_bar(position = position_dodge(), stat = "identity") + # stapeldiagram, där staplarna ligger intill varandra
  geom_errorbar(aes(ymin = lower.95ci * 100, ymax = upper.95ci * 100), # visa 95% CI
    width = .2,
    position = position_dodge(.9)
  ) +
  geom_text(aes(label = .data$"Antal svar"), # visa text
    position = position_dodge(width = 1),
    hjust = -0.1, vjust = -0.9
  ) +
  # geom_text(aes(label = paste0(procentText," +/- ",sprintf("%1.1f%%",round(sem*1.96*100,2))), y = 7, angle = 90),
  geom_text(aes(label = procentText, y = 1, angle = 0),
    position = position_dodge(width = 1),
    hjust = 0.5,
    color = "white"
  ) +
  scale_fill_viridis_d(begin = 0.3, end = 0.9, option = 7) + # sätt kulörskala
  theme(
    legend.position = "right",
    plot.caption = element_text(face = "italic", size = 8)
  ) +
  labs(
    title = "Hur mår du rent allmänt?",
    caption = "Siffrorna ovanför staplarna anger antalet respondenter i varje svarskategori.\n Svarta vertikala streck visar 95% konfidensintervall."
  )

12.0.4 Alla år, alla svarskategorier

Code

df.A1g %>% 
  filter(!is.na(Svarsalternativ)) %>% 
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(aes(tooltip = round(Procent,1)),
                         size = 4) +
  geom_line(aes(group = Svarsalternativ), linewidth = 1.5) +
  scale_y_continuous(limits = c(0,60), breaks = c(0,20,40,60)) +
  scale_x_discrete(guide = guide_axis(n.dodge = 2)) + 
  scale_color_manual(values = rev(c("#5C758B","#009CA6", "#F5A127","#B94F70", "#EC5D4F"))) +
  facet_wrap(~Kön) +
  labs(title = "Hur mår du rent allmänt?") +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code

#girafe(ggobj = MHCfigG)

12.1 Jämförelse enstaka fråga och MHC

Code

df.viz %>% 
  filter(!is.na(A1)) %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  ggplot(aes(x = A1, y = mhcScore)) +
  geom_violin(aes(fill = A1)) +
  geom_boxplot(width = .3, outlier.shape = NA, alpha = 0.6, notch = TRUE) +
  xlab("Svarskategorier") +
  ylab("Indexvärde MHC") +
  # geom_jitter(shape=16, position=position_jitter(0.2)) +
  # geom_point(data=errbar_lims, aes(x=q11, y=mean), size=3) + # this (and the sectoin below) requires data and aes to be defined only in geom_violin, for unknown reasons
  # geom_errorbar(data=errbar_lims, aes(x=q11, ymax=upper,
  #                   ymin=lower), stat='identity', width=.1) +
  # geom_crossbar(stat="summary", fun.y=mean, fun.ymax=mean, fun.ymin=mean, fatten=5, width=.5) +
  # geom_point(color="black", size=1, position = position_jitter(w=0.1)) +
  scale_fill_manual(values = rev(c("#5C758B","#009CA6", "#F5A127","#B94F70", "#EC5D4F"))) +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Enstaka fråga jämfört med indexvärde från MHC",
       caption = "MHC = Mental Health Continuum") +
  theme(
    legend.position = "none",
    text = element_text(family = "sans")
  ) +
  coord_flip() +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code

# get mode values for A1 categories on each mhc item, and calculate corresponding person score

Mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

# recode raw responses according to analysis
df.vizRecoded <- df.viz

for (i in scale.items) {
  df.vizRecoded[[i]] <- recode(df.vizRecoded[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

#create data frame with 0 rows and 8 columns
psf.modes <- data.frame(matrix(ncol = length(scale.items), nrow = 5))
names(psf.modes) <- scale.items
mydå <- c()
då <- c()
vbd <- c()
bra <- c()
mybra <- c()
# get the mode value from each risk group for each item
for (i in scale.items){
  mydå <- Mode(df.vizRecoded %>% filter(A1 == "Mycket dåligt") %>% select(i) %>% na.omit() %>% pull())
  då <- Mode(df.vizRecoded %>% filter(A1 == "Dåligt") %>% select(i) %>% na.omit() %>% pull())
  vbd <- Mode(df.vizRecoded %>% filter(A1 == "Varken bra eller dåligt") %>% select(i) %>% na.omit() %>% pull())
  bra <- Mode(df.vizRecoded %>% filter(A1 == "Bra") %>% select(i) %>% na.omit() %>% pull())
  mybra <- Mode(df.vizRecoded %>% filter(A1 == "Mycket bra") %>% select(i) %>% na.omit() %>% pull())
  psf.modes[[i]] <- rbind(mydå,då,vbd,bra,mybra)
}

# transform to dataframe with numeric variables for later extraction as vectors
psf.modes<- psf.modes %>% 
  t() %>% 
  as.data.frame()

# read item paramters for thetaEst
items <- as.matrix(read_csv("itemParameters.csv"))

12.2 MHC score baserat på typvärden utifrån single-item svarskategorier

Code

avg1 <- thetaEst(items, psf.modes$V1, model = "PCM", method = "WL")
sem1 <- semTheta(thEst = avg1, it = items, x = psf.modes$V1, model = "PCM", method = "WL")
avg2 <- thetaEst(items, psf.modes$V2, model = "PCM", method = "WL")
sem2 <- semTheta(thEst = avg2, it = items, x = psf.modes$V2, model = "PCM", method = "WL")
avg3 <- thetaEst(items, psf.modes$V3, model = "PCM", method = "WL")
sem3 <- semTheta(thEst = avg3, it = items, x = psf.modes$V3, model = "PCM", method = "WL")
avg4 <- thetaEst(items, psf.modes$V4, model = "PCM", method = "WL")
sem4 <- semTheta(thEst = avg4, it = items, x = psf.modes$V4, model = "PCM", method = "WL")
avg5 <- thetaEst(items, psf.modes$V5, model = "PCM", method = "WL")
sem5 <- semTheta(thEst = avg5, it = items, x = psf.modes$V5, model = "PCM", method = "WL")

I nedanstående figur har vi orangea streckade vertikala linjer som indikerar MHC score estimerat utifrån typvärden på samtliga items i MHC för de fem svarskategorierna.

Code

df.viz %>%
  filter(Årtal %in% c("2019", "2021")) %>%
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(
    side = "right", show.legend = F,
    scale = 0.6, # defines the height that a slab can reach
    position = position_dodge(width = .6), # distance between elements for dodging
    aes(fill_ramp = after_stat(level), fill = Årtal),
    .width = c(.50, .75, 1)
  ) + # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
               position = position_dodge2nudge(x=.05,width = .8)) +
  geom_vline(xintercept = avg1, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg1-sem1, xmax = avg1+sem1, alpha = .1) +
  annotate("text", label = "Mycket dåligt", x = avg1, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg2, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg2-sem2, xmax = avg2+sem2, alpha = .1) +
  annotate("text", label = "Dåligt", x = avg2, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg3, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg3-sem3, xmax = avg3+sem3, alpha = .1) +
  annotate("text", label = "Varken bra eller dåligt", x = avg3, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg4, color = "orange", linetype = 2) +
  annotate("text", label = "Bra", x = avg4, y = 1.5, angle = 90, size = 3) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg4-sem4, xmax = avg4+sem4, alpha = .1) +
  geom_vline(xintercept = avg5, color = "orange", linetype = 2) +
  annotate("text", label = "Mycket bra", x = avg5, y = 1.5, angle = 90, size = 3) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg5-sem5, xmax = avg5+sem5, alpha = .1) +
  scale_fill_ramp_discrete(from = "black", aesthetics = "fill_ramp") +
  # scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(
    axis.text.x = element_text(size = ax.size, family = "sans"),
    # axis.text.y = element_blank(),
    title = element_text(size = title.size),
  ) +
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer") +
    theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code

# "Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"

13 Rasch-analys med single-item

Code

# get item parameters for single-item

df.extra <- df.vizRecoded %>%
  select(starts_with("mhc"),A1num) %>%
  select(!mhcScore) %>%
  na.omit()

Item fit

Code

RIitemfitPCM2(df.extra, 250, 32, 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
mhc1	0.879	0.885	-1.404	-1.292
mhc4	1.34	1.239	2.038	2.389
mhc5	1.117	1.097	0.903	1.095
mhc6	1.108	1.065	0.737	0.892
mhc9	0.705	0.729	-3.13	-3.592
mhc10	0.921	0.913	-0.752	-1.179
mhc11	0.791	0.798	-1.83	-2.449
mhc12	0.935	0.922	-1.182	-0.964
mhc13	0.863	0.869	-1.568	-1.835
mhc14	0.664	0.698	-3.339	-4.078
A1num	1.193	1.163	1.788	1.491

PCA

Code

RIpcmPCA(df.extra)

PCA of Rasch model residuals

Eigenvalues
1.58
1.44
1.31
1.17
1.06

Residual correlations

Code

RIresidcorr(df.extra, cutoff = 0.2)

	mhc1	mhc4	mhc5	mhc6	mhc9	mhc10	mhc11	mhc12	mhc13	mhc14	A1num
mhc1
mhc4	-0.15
mhc5	-0.03	-0.04
mhc6	-0.1	0.03	-0.07
mhc9	-0.06	-0.19	-0.21	-0.09
mhc10	-0.16	-0.15	-0.18	-0.09	-0.03
mhc11	-0.02	-0.21	0.06	-0.15	-0.06	-0.01
mhc12	-0.2	-0.06	-0.2	-0.1	-0.11	-0.01	-0.04
mhc13	-0.17	-0.07	-0.15	-0.18	0.06	-0.14	-0.1	0.02
mhc14	-0.1	-0.14	-0.22	-0.12	-0.01	-0.03	-0.13	0.01	0.01
A1num	0.17	-0.18	-0.12	-0.08	-0.03	-0.12	-0.16	-0.26	-0.19	-0.03
Note:
Relative cut-off value (highlighted in red) is 0.108, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df.extra)

Analysis of response categories

Code

plot(mirt.rasch, type="trace")

Targeting

Code

# increase fig-height above as needed, if you have many items
RItargeting(df.extra)

Item hierarchy

Code

RIitemHierarchy(df.extra)

Reliabilitet

Code

RItif(df.extra)

13.1 Item-parametrar

Code

RIitemparams(df.extra, "itemParamsExtra.csv")

	Threshold 1	Threshold 2	Threshold 3	Threshold 4	Item location
mhc1	-1.79	-0.28	1.16	NA	-0.31
mhc4	0.92	1.80	2.12	NA	1.61
mhc5	-0.38	0.08	0.68	NA	0.13
mhc6	1.13	2.19	2.66	NA	1.99
mhc9	-0.61	0.55	1.22	NA	0.38
mhc10	-0.88	0.56	1.28	NA	0.32
mhc11	-1.20	0.12	0.81	NA	-0.09
mhc12	-0.63	1.08	1.33	NA	0.59
mhc13	-0.73	0.59	0.94	NA	0.26
mhc14	-0.38	0.72	0.89	NA	0.41
A1num	-2.56	-1.60	-0.50	1.86	-0.7

A1num (“Hur mår du rent allmänt?”) har location -0.70, att jämföra med respondenternas medelvärde på 0.55.

Code

barplot(table(df.extra$A1num), col = "#8dc8c7", main = "Hur mår du rent allmänt?",
      ylab = "Antal svar")

13.2 Jämförelse typvärdebaserat och itemtrösklar

I nedanstående figur har vi fortfarande orangea streckade vertikala linjer som indikerar MHC score estimerat utifrån typvärden på samtliga items i MHC för de fem svarskategorierna. Som tillägg finns nu röda linjer som indikerar var svarströsklarna ligger. Det vore kanske mera pedagogiskt att visa på högsta sannolikhet för varje svarskategori i stället, men det får bli en framtida utvecklingsmöjlighet.

Code

# get item threshold locations for item A1
itempse <- read.csv("itemParamsExtra.csv") %>% 
  na.omit() %>% 
  t() %>% 
  as.data.frame() %>% 
  pull('11')

df.viz %>%
  filter(Årtal %in% c("2019", "2021")) %>%
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(
    side = "right", show.legend = F,
    scale = 0.6, # defines the height that a slab can reach
    position = position_dodge(width = .6), # distance between elements for dodging
    aes(fill_ramp = after_stat(level), fill = Årtal),
    .width = c(.50, .80, 1)
  ) + # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  # stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
  #             position = position_dodge2nudge(x=.05,width = .8)) +
  geom_vline(xintercept = avg1, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg1-sem1, xmax = avg1+sem1, alpha = .1) +
  geom_vline(xintercept = avg2, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg2-sem2, xmax = avg2+sem2, alpha = .1) +
  geom_vline(xintercept = avg3, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg3-sem3, xmax = avg3+sem3, alpha = .1) +
  geom_vline(xintercept = avg4, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg4-sem4, xmax = avg4+sem4, alpha = .1) +
  geom_vline(xintercept = avg5, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg5-sem5, xmax = avg5+sem5, alpha = .1) +
  geom_vline(xintercept = itempse[1], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[2], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[3], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[4], color = "red", linetype = 5) +
  scale_fill_ramp_discrete(from = "black", aesthetics = "fill_ramp") +
  # scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(
    axis.text.x = element_text(size = ax.size, family = "sans"),
    # axis.text.y = element_blank(),
    title = element_text(size = title.size),
  ) +
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer")

Code

df.erm <- PCM(df.extra)
plotICC(df.erm, item.subset = "A1num", legpos = "topleft")

14 DIF-analys för A1

Vi vill säkerställa att A1, “Hur mår du rent allmänt?” fungerar lika för alla demografiska grupper som svarar på frågan.

Code

removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.omit.na <- df %>%
  filter(inars %in% c(2019)) %>%
  mutate(Årskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>%
  select(starts_with("I1_"),Årskurs,Kön,Skolkommun,A1num) %>%
  na.omit()

# create variables for analysis of Differential Item Functioning
dif.arskurs <- df.omit.na$Årskurs
dif.gender <- df.omit.na$Kön
dif.skolkommun <- df.omit.na$Skolkommun

df.omit.na$Årskurs <- NULL
df.omit.na$Kön <- NULL
df.omit.na$Skolkommun <- NULL

names(df.omit.na) <- c(itemlabels$itemnr,"A1num")

for (i in itemlabels$itemnr) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.omit.na <- df.omit.na %>% 
  select(!any_of(removed.items))

14.1 Kön

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df.omit.na, dif.gender)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.676	-0.636	-0.656	0.028	0.039
mhc4	1.153	1.155	1.154	0.001	0.001
mhc5	-0.445	-0.194	-0.320	0.177	0.251
mhc6	1.709	1.466	1.587	0.171	0.242
mhc9	0.106	-0.125	-0.010	0.163	0.231
mhc10	-0.271	0.008	-0.132	0.197	0.279
mhc11	-0.733	-0.317	-0.525	0.294	0.415
mhc12	0.102	0.257	0.179	0.109	0.155
mhc13	-0.095	-0.262	-0.178	0.118	0.167
mhc14	0.051	-0.078	-0.014	0.091	0.129
A1num	-0.900	-1.273	-1.086	0.263	0.372

Locations

Code

RIdifFigure(df.omit.na, dif.gender)

Thresholds

Code

RIdifFigThresh(df.omit.na, dif.gender)

Något högt värde för A1num, men ej över 0.5.

14.2 Årskurs

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df.omit.na, dif.arskurs)

Item	2	4	5	Mean location	StDev	MaxDiff
mhc1	-0.705	-0.704	-0.535	-0.648	0.098	0.170
mhc4	1.248	1.087	1.101	1.145	0.089	0.161
mhc5	-0.244	-0.329	-0.389	-0.321	0.073	0.145
mhc6	1.400	1.638	1.695	1.578	0.156	0.295
mhc9	0.014	-0.002	-0.054	-0.014	0.036	0.068
mhc10	-0.226	-0.137	0.024	-0.113	0.127	0.250
mhc11	-0.470	-0.496	-0.607	-0.524	0.073	0.137
mhc12	0.266	0.164	0.107	0.179	0.080	0.158
mhc13	-0.058	-0.187	-0.292	-0.179	0.117	0.234
mhc14	-0.015	-0.032	0.003	-0.015	0.017	0.034
A1num	-1.211	-1.002	-1.053	-1.089	0.109	0.209

Locations

Code

RIdifFigure(df.omit.na, dif.arskurs)

Thresholds

Code

RIdifFigThresh(df.omit.na, dif.arskurs)

Inga problem.

14.3 Kön och årskurs

Vi undersöker även interaktionen mellan kön och årskurs.

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Tabell

Code

dfin <- df.omit.na

df.tree <- data.frame(matrix(ncol = 0, nrow = nrow(dfin)))
df.tree$difdata <- as.matrix(dfin)
df.tree$dif.gender <- dif.gender
df.tree$dif.arskurs <- dif.arskurs

pctree.out <- pctree(difdata ~ dif.gender + dif.arskurs, data = df.tree)
plot(pctree.out)

Code

cutoff <- 0.5
diffig <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  mutate(
    `Mean location` = rowMeans(.),
    StDev = rowSds(as.matrix(.))
  ) %>%
  rowwise() %>%
  mutate(MaxDiff = (max(c_across(c(1:(ncol(.) - 2))))) -
    min(c_across(c(1:(ncol(.) - 2))))) %>%
  ungroup() %>%
  mutate(across(where(is.numeric), round, 3)) %>%
  rownames_to_column(var = "Item") %>%
  mutate(Item = names(dfin)) %>%
  relocate(MaxDiff, .after = last_col())

  formattable(diffig,
    list(MaxDiff = formatter("span",
      style = ~ style(color = ifelse(MaxDiff < -cutoff,
        "red", ifelse(MaxDiff > cutoff, "red", "black")
      ))
    ),
    formattable::area(col = 2:7) ~ color_tile(RISEprimYellowLight, RISEprimGreen)
    ),
    table.attr = "class=\"table table-striped\" style=\"font-size: 15px; font-family: Lato\""
  )

Item	3	5	6	8	10	11	Mean location	StDev	MaxDiff
mhc1	-0.694	-0.713	-0.604	-0.723	-0.699	-0.476	-0.651	0.096	0.247
mhc4	1.263	1.055	1.149	1.263	1.131	1.069	1.155	0.091	0.208
mhc5	-0.483	-0.380	-0.492	-0.005	-0.282	-0.310	-0.325	0.179	0.488
mhc6	1.606	1.741	1.838	1.284	1.587	1.603	1.610	0.187	0.554
mhc9	0.103	0.091	0.133	-0.069	-0.107	-0.211	-0.010	0.139	0.344
mhc10	-0.348	-0.314	-0.104	-0.108	0.031	0.121	-0.120	0.185	0.469
mhc11	-0.700	-0.706	-0.826	-0.242	-0.301	-0.429	-0.534	0.242	0.584
mhc12	0.203	0.085	-0.009	0.334	0.236	0.196	0.174	0.120	0.344
mhc13	-0.005	-0.111	-0.198	-0.130	-0.275	-0.410	-0.188	0.141	0.405
mhc14	0.038	0.021	0.118	-0.063	-0.077	-0.092	-0.009	0.082	0.210
A1num	-0.983	-0.769	-1.004	-1.541	-1.244	-1.063	-1.101	0.264	0.772

Figur

Code

pctree.par <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame()
pctree.par$Item <- names(dfin)
pctree.par$item <- NULL
rownames(pctree.par) <- NULL
pctree.par <- melt(pctree.par, id.vars = "Item")
names(pctree.par) <- c("Item", "Group", "Logits")
pctree.par$Item <- factor(pctree.par$Item, levels = names(dfin))
ggplot(pctree.par, aes(
  x = Item, y = Logits, color = Group,
  group = Group
)) +
  geom_line(linewidth = 1.5, alpha = 0.8) +
  geom_point(size = 2.5)

Code

nodes <- c("Flickor Åk 7","Flickor Åk 9","Flickor Gy 2","Pojkar Åk 7","Pojkar Åk 9","Pojkar Gy 2")

pctree.par %>% 
  filter(Item == "A1num") %>% 
  ggplot(aes(x = Group, y = Logits)) +
  geom_line(linewidth = 1.3, alpha = 0.8, group = 1, color = RISEprimGreen) +
  geom_point(size = 3, color = RISEprimGreen) +
  geom_text_repel(aes(label = round(Logits,2))) +
  geom_hline(aes(yintercept = pull(diffig[10,8])), 
             color = RISEcompPurple, linetype = 2) +
  scale_x_discrete(labels = nodes) +
  labs(title = "A1 - Hur mår du rent allmänt?")

Figur thresholds

Code

unidif <- threshpar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  rownames_to_column("Threshh") %>%
  pivot_longer(where(is.numeric)) %>%
  separate(Threshh,
    c("Item", "Threshold"),
    sep = "-"
  ) %>%
  separate(Item,
    c(NA, "Item"),
    sep = "ata"
  ) %>%
  dplyr::rename(
    `DIF node` = name,
    Location = value
  ) %>%
  mutate(`DIF node` = as.numeric(`DIF node`)) %>%
  mutate(Threshold = dplyr::recode(Threshold,
    C1 = "T1",
    C2 = "T2", C3 = "T3", C4 = "T4", C5 = "T5",
    C6 = "T6", C7 = "T7", C8 = "T8", C9 = "T9",
    C10 = "T10"
  )) %>%
  mutate(Item = factor(Item,
    levels = names(dfin)
  ))
ggplot(unidif, (aes(
  x = factor(`DIF node`), y = Location,
  group = Threshold, color = Threshold
))) +
  geom_line() +
  geom_point() +
  xlab("DIF node") +
  facet_wrap(~Item)

Code

unidif %>% 
  filter(`DIF node` %in% c(3,5,6,8)) %>% 
  filter(Item == "A1num") %>% 
  mutate(meanLocation = mean(Location), .by = `DIF node`) %>% 
  mutate(`DIF node` = car::recode(`DIF node`,"3='Flickor åk 7';5='Flickor åk 9';6='Flickor Gy 2';8='Pojkar åk 7'")
         ) %>% 
ggplot((aes(
  x = `DIF node`, y = Location,
  group = Threshold, color = Threshold
))) +
  geom_line(linewidth = 1.5) +
  geom_point(size = 4) +
  geom_point(aes(y = meanLocation), size = 4, shape = 18, 
        color = "black") +
  geom_text(aes(y = meanLocation-0.2, label = round(meanLocation,2)),
            color = "black") +
  xlab("DIF node")

Det är stor skillnad mellan Flickor åk 9 och Pojkar åk 7 på den övergripande frågan, vilket framgår tydligast under fliken “Figur” ovan.

14.4 Skolkommun

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df.omit.na, dif.skolkommun)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.683	-0.648	-0.665	0.025	0.035
mhc4	1.221	1.132	1.176	0.062	0.088
mhc5	-0.226	-0.337	-0.282	0.078	0.110
mhc6	1.408	1.598	1.503	0.134	0.190
mhc9	0.023	-0.022	0.001	0.031	0.044
mhc10	-0.200	-0.101	-0.150	0.070	0.099
mhc11	-0.496	-0.520	-0.508	0.017	0.025
mhc12	0.170	0.189	0.179	0.014	0.019
mhc13	-0.172	-0.169	-0.170	0.002	0.003
mhc14	-0.009	-0.020	-0.014	0.007	0.010
A1num	-1.035	-1.103	-1.069	0.048	0.068

Locations

Code

RIdifFigure(df.omit.na, dif.skolkommun)

Thresholds

Code

RIdifFigThresh(df.omit.na, dif.skolkommun)

Inga problem.

14.5 Årtal

Code

df.difyears <- df %>% 
  mutate(Årtal = factor(inars)) %>% 
  select(starts_with("I1_"),A1num,Årtal,kon_txt) %>% 
  na.omit()

dif.years <- df.difyears$Årtal
df.difyears$Årtal <- NULL
dif.genderyears <- factor(df.difyears$kon_txt)
df.difyears$kon_txt <- NULL

names(df.difyears) <- c(itemlabels$itemnr,"A1num")

for (i in itemlabels$itemnr) {
  df.difyears[[i]] <- recode(df.difyears[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.difyears <- df.difyears %>% 
  select(!any_of(removed.items))

itemnr	item
mhc1	lycka, glädje
mhc4	att du har något viktigt att bidra med till samhället
mhc5	att du tillhör en gemenskap
mhc6	att vårt samhälle håller på att bli en bättre plats
mhc9	att du gillar det mesta av din personlighet
mhc10	att du är bra på att ta ansvar för ditt dagliga liv
mhc11	att du har varma och tillitsfulla relationer med andra
mhc12	att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13	att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14	att du är på väg någonstans i livet och livet har en mening

Table

Code

RIdifTable(df.difyears, dif.years)

Item	2	3	Mean location	StDev	MaxDiff
mhc1	-0.647	-0.796	-0.722	0.105	0.149
mhc4	1.131	1.258	1.194	0.090	0.127
mhc5	-0.307	-0.290	-0.299	0.012	0.016
mhc6	1.540	1.632	1.586	0.065	0.092
mhc9	-0.015	-0.056	-0.035	0.029	0.041
mhc10	-0.117	-0.081	-0.099	0.025	0.036
mhc11	-0.505	-0.509	-0.507	0.003	0.004
mhc12	0.182	0.170	0.176	0.008	0.011
mhc13	-0.169	-0.152	-0.161	0.012	0.017
mhc14	-0.016	0.002	-0.007	0.012	0.018
A1num	-1.077	-1.177	-1.127	0.071	0.100

Locations

Code

RIdifFigure(df.difyears, dif.years)

Thresholds

Code

RIdifFigThresh(df.difyears, dif.years)

Inga problem.

14.6 DIF “Hur mår du rent allmänt?”

Eftersom frågan uppvisade ganska stor skillnad mellan pojkar åk 7 och flickor gy 2 gör vi ett exempel utifrån dessa grupper för att visa vad skillnaden består i och hur den kan visualiseras.

Vi gör först separata items av A1num för de två subgrupperna.

Code

df.difex <- df.omit.na %>% 
  select(!any_of(removed.items)) %>% 
  cbind(.,dif.arskurs) %>% 
  cbind(.,dif.gender) %>% 
  mutate(A1p7 = case_when(dif.arskurs == "Åk 7" & dif.gender == "Pojkar" ~ A1num,
                          .default = NA)) %>% 
  mutate(A1f2 = case_when(dif.arskurs == "Gy 2" & dif.gender == "Flickor" ~ A1num,
                          .default = NA)) %>% 
  select(!dif.gender) %>% 
  select(!dif.arskurs)

14.6.1 Targeting

Code

RItargeting(df.difex)

Svarskategorierna är “Mycket dåligt”,“Dåligt”,“Varken bra eller dåligt”,“Bra”,“Mycket bra”.

Den tydligaste skillnaden mellan de två subgrupperna är att tröskelvärdet mellan Dåligt och Varken bra eller dåligt (T2) för flickor gy 2 (item A1f2) är ungefär samma som mellan Varken bra eller dåligt och Bra (T3) för pojkar åk 7 (item A1p7).

14.6.2 Bra/Mycket bra

Code

df.erm <- PCM(df.difex)
dfin <- df.difex
xlim = c(-4,5)

item.estimates <- eRm::thresholds(df.erm)
  item_difficulty <- item.estimates[["threshtable"]][["1"]]
  item_difficulty <- as.data.frame(item_difficulty)
  item.se <- item.estimates$se.thresh
  person.locations.estimate <- person.parameter(df.erm)
   item.fit <- eRm::itemfit(person.locations.estimate)

  item.locations <- item_difficulty[, 2:ncol(item_difficulty)]
  names(item.locations) <- paste0("T", c(1:ncol(item.locations))) # re-number items
  itemloc.long <- item.locations %>%
    rownames_to_column() %>%
    dplyr::rename(names = "rowname") %>%
    mutate(names = factor(names, levels = rev(names(dfin)))) %>%
    pivot_longer(
      cols = starts_with("T"),
      names_to = "thresholds",
      values_to = "par_values"
    )

Code

### create df for ggplot histograms
  # person locations
  thetas <- as.data.frame(person.locations.estimate$theta.table)
  pthetas <- thetas$`Person Parameter`
  # item locations
  thresholds <- c()
  for (i in 2:ncol(item_difficulty)) {
    thresholds <- c(thresholds, item_difficulty[, i])
  }
  ### items and persons in the same variable
  #create data frame with 0 rows and 3 columns
  df.locations <- data.frame(matrix(ncol = 2, nrow = 0))
  # provide column names
  colnames(df.locations) <- c("type", "locations")
  # change type of data
  df.locations$type <- as.character(df.locations$type)
  df.locations$locations <- as.numeric(df.locations$locations)
  # insert labels in accurate amounts (N+items)
  nper <- nrow(dfin)
  nperp <- nper + 1
  nthr <- length(thresholds) + nper
  df.locations[1:nper, 1] <- paste0("Persons")
  df.locations[nperp:nthr, 1] <- paste0("Item thresholds")
  # insert data from vectors with thetas and thresholds
  df.locations$locations <- c(pthetas, thresholds)
  # change type to class factor
  df.locations$type <- as.factor(df.locations$type)

  # get mean/SD for item/person locations
  pi.locations <- data.frame(matrix(ncol = 3, nrow = 3))

Code

item.mean <- round(mean(item_difficulty$Location), 2)
  item.sd <- round(sd(item_difficulty$Location), 2)
  item.thresh.sd <- item_difficulty %>%
    dplyr::select(starts_with("Threshold")) %>%
    pivot_longer(everything()) %>%
    pull() %>%
    na.omit() %>%
    sd() %>%
    round(2)
  person.mean <- round(mean(pthetas), 2)
  person.sd <- round(sd(pthetas), 2)
  #provide column names
  colnames(pi.locations) <- c('','Mean', 'SD')
  pi.locations[1,1] <- "Items"
  pi.locations[1,2] <- round(mean(item_difficulty$Location),2)
  pi.locations[1,3] <- round(sd(item_difficulty$Location),2)
  pi.locations[2,1] <- "Item thresholds"
  pi.locations[2,2] <- round(mean(item_difficulty$Location),2)
  pi.locations[2,3] <- item.thresh.sd
  pi.locations[3,1] <- "Persons"
  pi.locations[3,2] <- round(mean(pthetas),2)
  pi.locations[3,3] <- round(sd(pthetas),2)

Code

# Person location histogram
  p2 <- df.locations %>% 
  filter(type == "Persons") %>% 
    ggplot() +
    geom_histogram(
      aes(locations, fill = "Persons", y = after_stat(count))
    ) +
    xlab("") +
    ylab("Persons") +
    scale_x_continuous(limits = xlim, breaks = scales::pretty_breaks(n = 10)) +
    geom_vline(xintercept = -0.8145551, color = "#0e4e65", linetype = 2) +
      geom_vline(xintercept = 0.2181891 , color = "orange", linetype = 2) +

    #annotate("rect", ymin = 0, ymax = Inf, xmin = (person.mean - person.sd), xmax = (person.mean + person.sd), alpha = .2) +
    theme_bw() +
    theme(
      legend.position = "none",
      text = element_text(family = "sans")
    )

# make plot with each items thresholds shown as dots

  p1 <- 
    itemloc.long %>% 
    filter(str_detect(names,"A1")) %>% 
    ggplot(aes(x = names, y = par_values, label = thresholds, color = names)) +
    geom_point() +
    geom_text(hjust = 1.1, vjust = 1) +
    ylab("Location (logit scale)") +
    xlab("Items") +
      geom_hline(yintercept = -0.8145551, color = "#0e4e65", linetype = 2) +
      geom_hline(yintercept = 0.2181891 , color = "orange", linetype = 2) +
    scale_y_continuous(limits = xlim, breaks = scales::pretty_breaks(n = 10)) +
    theme_bw() +
    theme(legend.position = "none") +
    coord_flip() +
    theme(plot.caption = element_text(hjust = 0, face = "italic"))

Code

plot_grid(p2,p1, labels=NULL, nrow = 2, align ="hv", rel_heights = c(1.4,1.4))

Skillnader på gränsvärden indikeras av streckade linjer.

Code

object <- PCM(df.difex)
xlim <- c(-4,4)
theta  <- seq(xlim[1], xlim[2], length.out = 111L)   # x-axis

plist.internal <- function(object, theta){

  X <- object$X
  mt_vek <- apply(X, 2L, max, na.rm = TRUE)   # number of categories - 1 for each item
  mt_ind <- rep(seq_along(mt_vek), mt_vek)

  #--------compute list matrix of probabilites for fixed theta)
  p.list <- tapply(object$betapar, mt_ind, function(beta.i){
    beta.i <- c(0, beta.i)
    ind.h <- 0:(length(beta.i)-1)
    theta.h <- tcrossprod(ind.h, theta) # ind.h %*% t(theta) # multiply category with
    tb <- exp(theta.h + beta.i)
    denom <- colSums(tb)
    pi.mat <- apply(tb, 1L, function(y){ y/denom })
    return(pi.mat)
  })
  return(p.list)
}

p.list <- plist.internal(object, theta)              # matrix of probabilities
th.ord <- order(theta)

textlab <- colnames(object$X)
ivec <- seq_along(p.list)

Code

# choose item number
yp <- as.matrix(p.list[[12]]) # A1p7
yy <- yp[th.ord,]

# plot objects
x = sort(theta) # vector for x axis
y = yp[th.ord,] # matrix with one vector per response category
ylim = c(0,1)
xlim = c(-4,4)

df.icc <- data.frame(matrix(ncol = 0, nrow = 111))
df.icc <- rbind(df.icc,as.data.frame(y))
df.icc$x <- sort(theta)

categories <- c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra")

df.icc <- df.icc %>%
  pivot_longer(!x) %>%
  rename(Category = name,
         Probability = value)

# choose item number
yp <- as.matrix(p.list[[13]]) # A1f2
yy <- yp[th.ord,]

# plot objects
x = sort(theta) # vector for x axis
y = yp[th.ord,] # matrix with one vector per response category
ylim = c(0,1)
xlim = c(-4,4)

df.iccF2 <- data.frame(matrix(ncol = 0, nrow = 111))
df.iccF2 <- rbind(df.iccF2,as.data.frame(y))
df.iccF2$x <- sort(theta)

categories <- c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra")

df.iccF2 <- df.iccF2 %>%
  pivot_longer(!x) %>%
  rename(Category = name,
         Probability = value)

14.6.3 Figur Flickor gy 2

Code

ggplot(data = df.iccF2, aes(x = x, y = Probability, color = Category, group = Category)) +
  #geom_point(data = df.iccF2, size = 0.2, alpha = 0.3) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Flickor gy 2")

14.6.4 Figur Pojkar åk 7

Code

ggplot(data = df.icc, aes(x = x, y = Probability, color = Category, group = Category)) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Pojkar åk 7")

14.6.5 Gemensam figur

Code

ggplot(data = df.icc, aes(x = x, y = Probability, color = Category, group = Category)) +
  geom_point(data = df.iccF2, size = 0.2, alpha = 0.3) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
    caption = "Streckad linje = Flickor gy 2. Heldragen linje = Pojkar åk 7")

15 Programvara som använts för analyserna

Code

pkgs <- cite_packages(cite.tidyverse = TRUE, 
                      output = "table",
                      bib.file = "grateful-refs.bib",
                      include.RStudio = TRUE,
                      out.dir = getwd())
formattable(pkgs, 
            table.attr = 'class=\"table table-striped\" style="font-size: 14px; font-family: Lato; width: 80%"')

Package	Version	Citation
arrow	12.0.1.1	Richardson et al. (2023)
base	4.2.3	R Core Team (2023)
car	3.1.2	Fox and Weisberg (2019)
colorspace	2.1.0	Zeileis, Hornik, and Murrell (2009); Stauffer et al. (2009); Zeileis et al. (2020)
cowplot	1.1.1	Wilke (2020)
eRm	1.0.2	Mair and Hatzinger (2007b); Mair and Hatzinger (2007a); Hatzinger and Rusch (2009); Rusch, Maier, and Hatzinger (2013); Koller, Maier, and Hatzinger (2015); Debelak and Koller (2019); Mair, Hatzinger, and Maier (2021)
foreach	1.5.2	Microsoft and Weston (2022)
formattable	0.2.1	Ren and Russell (2021)
furrr	0.3.1	Vaughan and Dancho (2022)
ggdist	3.3.0	Kay (2023)
ggiraph	0.8.7	Gohel and Skintzos (2023)
ggpp	0.5.4	Aphalo (2023)
ggrepel	0.9.3	Slowikowski (2023)
glue	1.6.2	Hester and Bryan (2022)
kableExtra	1.3.4	Zhu (2021)
knitr	1.42	Xie (2014); Xie (2015); Xie (2023)
matrixStats	0.63.0	Bengtsson (2022)
mirt	1.40	Chalmers (2012)
psych	2.3.6	William Revelle (2023)
psychotree	0.16.0	Trepte and Verbeet (2010); Strobl, Wickelmaier, and Zeileis (2011); Strobl, Kopf, and Zeileis (2015); Komboz, Zeileis, and Strobl (2018); Wickelmaier and Zeileis (2018)
reshape	0.8.9	Wickham (2007)
RISEkbmRasch	0.1.20.0	Johansson (2023)
rmarkdown	2.22	Xie, Allaire, and Grolemund (2018); Xie, Dervieux, and Riederer (2020); Allaire et al. (2023)
scales	1.2.1	Wickham and Seidel (2022)
tidyverse	2.0.0	Wickham et al. (2019)

16 Referenser

Allaire, JJ, Yihui Xie, Christophe Dervieux, Jonathan McPherson, Javier Luraschi, Kevin Ushey, Aron Atkins, et al. 2023. rmarkdown: Dynamic Documents for r. https://github.com/rstudio/rmarkdown.

Aphalo, Pedro J. 2023. ggpp: Grammar Extensions to “ggplot2”. https://CRAN.R-project.org/package=ggpp.

Bengtsson, Henrik. 2022. matrixStats: Functions That Apply to Rows and Columns of Matrices (and to Vectors). https://CRAN.R-project.org/package=matrixStats.

Chalmers, R. Philip. 2012. “mirt: A Multidimensional Item Response Theory Package for the R Environment.” Journal of Statistical Software 48 (6): 1–29. https://doi.org/10.18637/jss.v048.i06.

Debelak, Rudolf, and Ingrid Koller. 2019. “Testing the Local Independence Assumption of the Rasch Model With Q3-Based Nonparametric Model Tests.” Applied Psychological Measurement. https://doi.org/10.1177/0146621619835501.

Fox, John, and Sanford Weisberg. 2019. An R Companion to Applied Regression. Third. Thousand Oaks CA: Sage. https://socialsciences.mcmaster.ca/jfox/Books/Companion/.

Gohel, David, and Panagiotis Skintzos. 2023. ggiraph: Make “ggplot2” Graphics Interactive. https://CRAN.R-project.org/package=ggiraph.

Hatzinger, Reinhold, and Thomas Rusch. 2009. “IRT models with relaxed assumptions in eRm: A manual-like instruction.” Psychology Science Quarterly 51.

Hester, Jim, and Jennifer Bryan. 2022. glue: Interpreted String Literals. https://CRAN.R-project.org/package=glue.

Johansson, Magnus. 2023. RISEkbmRasch: Psychometric Analysis in r with Rasch Measurement Theory. https://github.com/pgmj/RISEkbmRasch.

Kay, Matthew. 2023. ggdist: Visualizations of Distributions and Uncertainty. https://doi.org/10.5281/zenodo.3879620.

Koller, Ingrid, Marco Johannes Maier, and Reinhold Hatzinger. 2015. “An Empirical Power Analysis of Quasi-Exact Tests for the Rasch Model: Measurement Invariance in Small Samples.” Methodology 11. https://doi.org/10.1027/1614-2241/a000090.

Komboz, Basil, Achim Zeileis, and Carolin Strobl. 2018. “Tree-Based Global Model Tests for Polytomous Rasch Models.” Educational and Psychological Measurement 78 (1): 128–66. https://doi.org/10.1177/0013164416664394.

Mair, Patrick, and Reinhold Hatzinger. 2007a. “CML based estimation of extended Rasch models with the eRm package in R.” Psychology Science 49.

———. 2007b. “Extended Rasch modeling: The eRm package for the application of IRT models in R.” Journal of Statistical Software 20. https://www.jstatsoft.org/v20/i09.

Mair, Patrick, Reinhold Hatzinger, and Marco Johannes Maier. 2021. eRm: Extended Rasch Modeling. https://cran.r-project.org/package=eRm.

Microsoft, and Steve Weston. 2022. foreach: Provides Foreach Looping Construct. https://CRAN.R-project.org/package=foreach.

R Core Team. 2023. R: A Language and Environment for Statistical Computing. Vienna, Austria: R Foundation for Statistical Computing. https://www.R-project.org/.

Ren, Kun, and Kenton Russell. 2021. formattable: Create “Formattable” Data Structures. https://CRAN.R-project.org/package=formattable.

Richardson, Neal, Ian Cook, Nic Crane, Dewey Dunnington, Romain François, Jonathan Keane, Dragoș Moldovan-Grünfeld, Jeroen Ooms, and Apache Arrow. 2023. arrow: Integration to “Apache” “Arrow”. https://CRAN.R-project.org/package=arrow.

Rusch, Thomas, Marco Johannes Maier, and Reinhold Hatzinger. 2013. “Linear logistic models with relaxed assumptions in R.” In Algorithms from and for Nature and Life, edited by Berthold Lausen, Dirk van den Poel, and Alfred Ultsch. Studies in Classification, Data Analysis, and Knowledge Organization. New York: Springer. https://doi.org/10.1007/978-3-319-00035-0_34.

Slowikowski, Kamil. 2023. ggrepel: Automatically Position Non-Overlapping Text Labels with “ggplot2”. https://CRAN.R-project.org/package=ggrepel.

Stauffer, Reto, Georg J. Mayr, Markus Dabernig, and Achim Zeileis. 2009. “Somewhere over the Rainbow: How to Make Effective Use of Colors in Meteorological Visualizations.” Bulletin of the American Meteorological Society 96 (2): 203–16. https://doi.org/10.1175/BAMS-D-13-00155.1.

Strobl, Carolin, Julia Kopf, and Achim Zeileis. 2015. “Rasch Trees: A New Method for Detecting Differential Item Functioning in the Rasch Model.” Psychometrika 80 (2): 289–316. https://doi.org/10.1007/s11336-013-9388-3.

Strobl, Carolin, Florian Wickelmaier, and Achim Zeileis. 2011. “Accounting for Individual Differences in Bradley-Terry Models by Means of Recursive Partitioning.” Journal of Educational and Behavioral Statistics 36 (2): 135–53. https://doi.org/10.3102/1076998609359791.

Trepte, Sabine, and Markus Verbeet, eds. 2010. Allgemeinbildung in Deutschland – Erkenntnisse Aus Dem SPIEGEL Studentenpisa-Test. Wiesbaden: VS Verlag.

Vaughan, Davis, and Matt Dancho. 2022. furrr: Apply Mapping Functions in Parallel Using Futures. https://CRAN.R-project.org/package=furrr.

Wickelmaier, Florian, and Achim Zeileis. 2018. “Using Recursive Partitioning to Account for Parameter Heterogeneity in Multinomial Processing Tree Models.” Behavior Research Methods 50 (3): 1217–33. https://doi.org/10.3758/s13428-017-0937-z.

Wickham, Hadley. 2007. “Reshaping Data with the Reshape Package.” Journal of Statistical Software 21 (12). https://www.jstatsoft.org/v21/i12/.

Wickham, Hadley, Mara Averick, Jennifer Bryan, Winston Chang, Lucy D’Agostino McGowan, Romain François, Garrett Grolemund, et al. 2019. “Welcome to the tidyverse.” Journal of Open Source Software 4 (43): 1686. https://doi.org/10.21105/joss.01686.

Wickham, Hadley, and Dana Seidel. 2022. scales: Scale Functions for Visualization. https://CRAN.R-project.org/package=scales.

Wilke, Claus O. 2020. cowplot: Streamlined Plot Theme and Plot Annotations for “ggplot2”. https://CRAN.R-project.org/package=cowplot.

William Revelle. 2023. psych: Procedures for Psychological, Psychometric, and Personality Research. Evanston, Illinois: Northwestern University. https://CRAN.R-project.org/package=psych.

Xie, Yihui. 2014. “knitr: A Comprehensive Tool for Reproducible Research in R.” In Implementing Reproducible Computational Research, edited by Victoria Stodden, Friedrich Leisch, and Roger D. Peng. Chapman; Hall/CRC.

———. 2015. Dynamic Documents with R and Knitr. 2nd ed. Boca Raton, Florida: Chapman; Hall/CRC. https://yihui.org/knitr/.

———. 2023. knitr: A General-Purpose Package for Dynamic Report Generation in r. https://yihui.org/knitr/.

Xie, Yihui, J. J. Allaire, and Garrett Grolemund. 2018. R Markdown: The Definitive Guide. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown.

Xie, Yihui, Christophe Dervieux, and Emily Riederer. 2020. R Markdown Cookbook. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown-cookbook.

Zeileis, Achim, Jason C. Fisher, Kurt Hornik, Ross Ihaka, Claire D. McWhite, Paul Murrell, Reto Stauffer, and Claus O. Wilke. 2020. “colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes.” Journal of Statistical Software 96 (1): 1–49. https://doi.org/10.18637/jss.v096.i01.

Zeileis, Achim, Kurt Hornik, and Paul Murrell. 2009. “Escaping RGBland: Selecting Colors for Statistical Graphics.” Computational Statistics & Data Analysis 53 (9): 3259–70. https://doi.org/10.1016/j.csda.2008.11.033.

Zhu, Hao. 2021. kableExtra: Construct Complex Table with “kable” and Pipe Syntax. https://CRAN.R-project.org/package=kableExtra.

Reuse

https://creativecommons.org/licenses/by/4.0/